home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / UNI._c < prev    next >
Text File  |  1990-12-08  |  14KB  |  494 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     ** 
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "errors.h"
  20. #include "atoms.h"
  21. #include "manager.h"
  22.  
  23. /* 
  24.  
  25. When backtracking occurs, it is necessary to undo the variable bindings
  26. introduced during execution of the failed clauses.  For this purpose,
  27. certain critical bindings are recorded on an auxiliary stack called the
  28. trail.  The critical bindings are those involving variables created in
  29. environments older than choicepoint: those newer than choicepoint will
  30. disappear when the stacks contract.
  31.  
  32. */
  33.  
  34. #if P8000
  35. #define reg1 register
  36. #define reg2 register
  37. #define reg3 register
  38. #define reg4 register
  39. #define reg5 register
  40. #define reg6 register
  41. #endif
  42.  
  43. #if RISCOS
  44. #define reg1 register
  45. #define reg2 register
  46. #define reg3 register
  47. #define reg4 register
  48. #endif
  49.  
  50.  
  51. #if MSC 
  52. #define reg1 register
  53. #define reg2 register
  54. #endif
  55.  
  56. #ifndef reg1
  57. #define reg1 
  58. #endif
  59. #ifndef reg2
  60. #define reg2 
  61. #endif
  62. #ifndef reg3
  63. #define reg3 
  64. #endif
  65. #ifndef reg4
  66. #define reg4 
  67. #endif
  68. #ifndef reg5
  69. #define reg5 
  70. #endif
  71. #ifndef reg6
  72. #define reg6 
  73. #endif
  74. #ifndef reg7
  75. #define reg7
  76. #endif
  77. #ifndef reg8
  78. #define reg8
  79. #endif
  80. #ifndef reg9
  81. #define reg9
  82. #endif
  83. #ifndef reg10
  84. #define reg10
  85. #endif
  86. #ifndef reg11
  87. #define reg11
  88. #endif
  89. #ifndef reg12
  90. #define reg12
  91. #endif
  92.  
  93. /*
  94. EXPORT   boolean UNIFY();
  95. EXPORT   boolean INTRES(), LONGRES();
  96. EXPORT  void KILLSTACKS();
  97. EXPORT   ENV NEWENV(int);
  98. EXPORT   ENV ENVTOP;
  99. EXPORT  TRAIL TRAILEND;
  100. EXPORT TERM DEREF();
  101. */
  102.  
  103. IMPORT TERM HEAPTOP; /* from manager.c */
  104. IMPORT ATOM ATOMSTOP; /* from manager.c */
  105. IMPORT STRING STRINGSTOP;
  106. IMPORT TERM GLOTOP;
  107. IMPORT ENV CHOICEPOINT;
  108. IMPORT boolean OCHECK;
  109. IMPORT void ABORT();      /* from io.c */
  110. IMPORT void reclaim_heap();
  111. FORWARD boolean UNIFY();
  112.  
  113. #if !INLINE
  114. GLOBAL TERM DEREF(register TERM x, register TERM b)
  115. { if(name(x)==UNBOUNDT) 
  116.     { if(is_heapterm(x)) return mkfreevar(); }
  117.   else
  118.     { if(name(x)==SKELT) x=b+offset(x); 
  119.       while(name(x)==VART) x=val(x); 
  120.     }
  121.   return x;
  122. }
  123. #endif
  124.  
  125.  
  126. #if !POINTEROFFSET
  127. GLOBAL TRAIL TRAILEND=trail_units(1);
  128. GLOBAL TRAIL BASETRAIL=trail_units(1);
  129. #define ENDTRAILER MAXTRAILER
  130. #endif
  131.  
  132. #if POINTEROFFSET
  133. #ifdef DYNMEM
  134. GLOBAL TRAIL TRAILEND;
  135. GLOBAL TRAIL BASETRAIL;
  136. GLOBAL TRAIL ENDTRAILER;
  137. #else
  138. GLOBAL TRAIL TRAILEND= &TRAILTAB[1];
  139. GLOBAL TRAIL BASETRAIL= &TRAILTAB[1];
  140. GLOBAL TRAIL ENDTRAILER= &TRAILTAB[MAXTRAILER];
  141. #endif
  142. #endif
  143.  
  144. GLOBAL ENV   ENVTOP=env_units(1);
  145. GLOBAL ENV   BASEENV=env_units(1);
  146.  
  147.  
  148. /*
  149.    Specialized unification algorithm for returning integer results.
  150.    IntResult(x, i) is equivalent to Unify(x, MakeInt(i), ee, 0, 0)
  151.    but avoids allocating a global node.
  152. */
  153.  
  154. GLOBAL boolean INTRES (register TERM X, register int I)
  155. { 
  156.   deref(X);
  157.   if(name(X)==INTT) return ival(X)==I;
  158.   if(name(X)==UNBOUNDT)
  159.      { name(X)=INTT; ival(X)=I; 
  160.        if(X<base(CHOICEPOINT)) 
  161.           { if(TRAILEND >=ENDTRAILER) ABORT(TRAILSPACEE);
  162.             boundvar(TRAILEND)=X; 
  163.             inc_trail(TRAILEND); }
  164.        return true; 
  165.      }
  166.   return false;
  167. }
  168.  
  169.  
  170. #if LONGARITH
  171. GLOBAL boolean LONGRES(TERM T, long L)
  172. {
  173.    if(minint<=L && L<=maxint)
  174.      return INTRES(T,(int)L);
  175.    else return UNI(T,mklong(L));
  176. }
  177. #endif
  178. /*
  179.  
  180. The abstract Prolog machine contains two stacks, the local stack and
  181. the global stack.  The local stack is held in the global array
  182. 'display', with local variables in the global array 'locstack'.  These
  183. arrays have stack pointers 'envtop' and 'loctop' respectively.  The
  184. global stack is held as a chain of nodes starting at 'glotop'.
  185.  
  186. */
  187.  
  188. /* Create a new environment e. */
  189.  
  190. /*
  191.    Do not alterate Newenv
  192.    Newenv is used in execute as inline-code
  193.  */
  194. GLOBAL ENV NEWENV (REGISTER int VAR_SIZES)
  195. { register ENV EP; register TERM T;
  196.   if((EP=ENVTOP)>=MAXENVS) ABORT(FRAMESPACEE);
  197.   inc_env(ENVTOP);
  198.   choice(EP)=CHOICEPOINT;
  199.   trail(EP)=TRAILEND;
  200.   atomtop(EP)=ATOMSTOP;
  201.   base(EP)=T=GLOTOP;
  202.   if((GLOTOP+=(unsigned)VAR_SIZES) >=HEAPTOP) reclaim_heap(true);
  203.   while(dec_term(VAR_SIZES)>=0)
  204.     { name(T)=UNBOUNDT; inc_term(T); } 
  205.   return EP;
  206. }
  207.  
  208.  
  209. /*
  210.    Dispose of all environments after newtop, together with all
  211.    associated global storage, and undo critical variable bindings.
  212.    Do not alterate Killstacks
  213.    Killstacks is used in execute as inline-code
  214.  */
  215. GLOBAL void KILLSTACKS (register ENV N)
  216. { if(ENVTOP>=N)
  217.     { register TRAIL  Q,QQ; 
  218.       CHOICEPOINT=choice(N);
  219.       ATOMSTOP=atomtop(N);
  220.       STRINGSTOP= (STRING)nextatom(ATOMSTOP);
  221.       GLOTOP=base(N);
  222.       ENVTOP=N;
  223.       Q=TRAILEND; TRAILEND=QQ=trail(N);
  224.       while(QQ<Q) 
  225.         { name(boundvar(QQ))=UNBOUNDT; inc_trail(QQ); }
  226.     }
  227. }
  228.  
  229. /* 
  230. Unify implements the unification algorithm, which finds the most
  231. general common instance of a pair of terms. It performs the matching
  232. substitution by introducing variable bindings.  The occur check
  233. is executed only if the corresponding flag is set.
  234. */
  235.  
  236. #if OCCUR_CHECK
  237. LOCAL boolean O_Check(reg3 int N, reg5 TERM V, reg4 TERM T, 
  238.                       reg6 TERM BT, int DEPTH)
  239. { /* returns true, if V is an element of T */
  240.   reg1 TERM S=T; 
  241.   reg2 ATOM A;
  242.   if(N==0) return false;
  243.   if(DEPTH==0)ABORT(DEPTHE);
  244.   for(;;)
  245.   {  
  246.     if(name(S)==SKELT) S=BT+offset(S); 
  247.     while(name(S)==VART) S=val(S);
  248.     if(name(S)==UNBOUNDT) return (S==V);
  249.     if(O_Check(arity(name(S)),V,son(S),BT,DEPTH-1)) return true; 
  250.     if(--N==0) break;
  251.     S=next_br(T);
  252.   } 
  253.   return false;
  254. }
  255. #endif
  256.  
  257.  
  258. /* 
  259.    BIND creates a copy of the given argument list X on the stack
  260.    N - length of argument list;
  261.    X - pointer to first argument (X is assumed to be on heap);
  262.    B - base of the current environment for X;
  263. */
  264.  
  265. #define bindspace(N) \
  266.                { if((GLOTOP+=term_units(N))>=HEAPTOP) reclaim_heap(true); }
  267.  
  268. LOCAL TERM BIND( reg6 int N, reg2 TERM X, reg4 TERM B)
  269. {
  270.   reg2 TERM Y;
  271.   reg4 TERM T;
  272.   T=Y=GLOTOP;
  273. bind_top:
  274.   bindspace(N);
  275.  
  276.   for(;;)
  277.     if(name(X)==SKELT) 
  278.     { reg6 TERM S;
  279.       S=B+offset(X);
  280.       while(name(S)==VART) S=val(S); 
  281.       name(Y)=VART; val(Y)=S;
  282.       if(--N==0)goto ret;
  283.       next_br(X);next_br(Y);continue;
  284.     }
  285.     else 
  286.     { reg6 int S;
  287.       if(S=arity(name(Y)=name(X)))
  288.         { if(--N !=0) son(Y)=BIND(S,son(X),B);
  289.           else { N=S;Y=son(Y)=GLOTOP; X=son(X); goto bind_top; }
  290.           next_br(Y);next_br(X); continue;
  291.         }
  292.       else val(Y)=val(X);
  293.       if(--N==0)goto ret;
  294.       next_br(X);next_br(Y);continue;
  295.     }
  296.  ret: return T;
  297. }
  298.  
  299. /* Unify x1 and x2.  Perform the matching substitution
  300.    by binding variables. */
  301. #if ! INLINE
  302. GLOBAL boolean UNI(TERM Y1, TERM Y2)
  303. { return UNIFY(1,Y1,Y2,BE,BE,MAXDEPTH); }
  304. #endif
  305.  
  306.  
  307.  
  308. GLOBAL boolean UNIFY (int N, TERM Y1, TERM Y2, TERM B1, TERM B2, 
  309.                       int DEPTH)
  310. { reg1 TERM X1=Y1; reg2 TERM X2=Y2; 
  311.   reg4 ATOM A1; reg3 ATOM A2; reg5 TERM BC; 
  312.   TERM TOP; TRAIL TEND; card TAILRECUR=DEPTH; 
  313.  
  314. #define trailing(v,h)        {if(v<BC) { boundvar(TRAILEND)=v;\
  315.               if(inc_trail(TRAILEND)>=ENDTRAILER) ABORT(TRAILSPACEE);}}
  316. #define dereferencing(x,b) {if(name(x)==SKELT) x=b+offset(x);\
  317.                       while(name(x)==VART) x=val(x);}
  318. #define varbind(x,y)       { if(x<y)\
  319.         {name(y)=VART; val(y)=x; trailing(y,A1); }\
  320.         else { if(heap_term(x)) goto nextbrother;\
  321.           else if(x>y) {name(x)=VART;val(x)=y; trailing(x,A1);}}}
  322. #undef  annontvar
  323. #define annontvar          heap_term
  324. #if OCCUR_CHECK
  325. #define occurcheck(ar,v,t,b){if(OCHECK && \
  326.                       O_Check(ar,v,son(t),b,MAXDEPTH))goto failure;}
  327. #define occur1check(n,v,t,b){if(OCHECK && arity(n))\
  328.                  if(O_Check(arity(n),v,son(t),b,MAXDEPTH))goto failure;}
  329. #endif
  330. #if !OCCUR_CHECK
  331. #define occurcheck(ar,v,t,b)
  332. #define occur1check(n,v,t,b)
  333. #endif
  334. #define heap_term(x)  (x>GLOTOP)
  335. #define stack_term(x) (x<=GLOTOP)
  336.  
  337.   if(DEPTH==0) ABORT(DEPTHE);
  338.   TEND=TRAILEND;
  339.   TOP=GLOTOP;
  340.   BC=base(CHOICEPOINT); 
  341. deref_top:   
  342.   for(;;)
  343.     { A2=name(X2);
  344.       
  345.       if(A2>FUNCNAME)
  346.         { dereferencing(X1,B1); 
  347.           if((A1=name(X1))!=A2) 
  348.             { if(A1==UNBOUNDT) 
  349.                 { if(annontvar(X1)) goto nextbrother;
  350.                   trailing(X1,A1); 
  351.                   if(A1=arity(A2)) goto func3; 
  352.                   name(X1)=A2;son(X1)=nil_term;goto nextbrother;}
  353.               goto failure;
  354.             }
  355.           if(A1=arity(A2)) goto func4;
  356.           goto nextbrother;
  357.         } 
  358.       if(A2==SKELT)
  359.         { X2=B2+offset(X2); 
  360.           if((A2=name(X2))==UNBOUNDT) goto unboundt2;
  361.           else if(A2 !=VART) goto func2;
  362.           goto vart2;
  363.         }
  364.       if(A2==UNBOUNDT) 
  365.         { if(annontvar(X2)) goto nextbrother; 
  366.           goto unboundt2;
  367.         }
  368.       if(A2==VART) 
  369.         { vart2: 
  370.           do X2=val(X2);while(name(X2)==VART);
  371.           A2=name(X2); 
  372.         }
  373.       if(A2==UNBOUNDT) 
  374.         { unboundt2: dereferencing(X1,B1); 
  375.           if((A1=name(X1))>FUNCNAME)
  376.             { trailing(X2,A2);
  377.               if(stack_term(X1))
  378.                 { occur1check(A1,X2,X1,B1);
  379.                   name(X2)=A1; son(X2)=son(X1);
  380.                 }
  381.               else if(A2=arity(A1))
  382.                 { occurcheck((int)A2,X2,X1,B1);
  383.                   name(X2)=A1; 
  384.                 bind1:
  385.                   X2=son(X2)=GLOTOP;
  386.                   X1=son(X1);
  387.                   bindspace(A2);
  388.                   for(;;)
  389.                     { if(name(X1)==SKELT) 
  390.                         { register TERM X;
  391.                           X=B1+offset(X1); 
  392.                           while(name(X)==VART) X=val(X);
  393.                           name(X2)=VART;val(X2)=X; 
  394.                           if(--A2==0) break;
  395.                           next_br(X1); next_br(X2);continue;
  396.                         }
  397.                       name(X2)=A1=name(X1); 
  398.                       if(--A2==0)
  399.                         { 
  400.                           if(A1==INTT) { ival(X2)=ival(X1);break;}
  401.                           if(A2=arity(A1)) goto bind1; 
  402.                           else son(X2)=nil_term;
  403.                           break;
  404.                         }
  405.                       else
  406.                         { if(A1=arity(A1))
  407.                             { son(X2)=BIND((int)A1,son(X1),B1);}
  408.                           else val(X2)=val(X1);
  409.                           next_br(X1);next_br(X2);
  410.                         }
  411.                     }
  412.                 }
  413.               else { name(X2)=A1; son(X2)=nil_term; }
  414.             } 
  415.           else if(A1!=A2)
  416.             {name(X2)=A1;ival(X2)=A1=ival(X1);trailing(X2,A2);}
  417.           else /* A1==UNBOUNDT */
  418.               varbind(X1,X2)
  419.         }
  420.       else 
  421.         { func2: dereferencing(X1,B1); 
  422.           if((A1=name(X1))!=A2) 
  423.             if(A1==UNBOUNDT)
  424.               { if(annontvar(X1)) goto nextbrother;
  425.                 trailing(X1,A1);
  426.                 if(A1=arity(A2))
  427.                   { func3: 
  428.                     occurcheck((int)A1,X1,X2,B2);
  429.                     name(X1)=A2;
  430.                     if(X2>GLOTOP)   /* heap_term */
  431.                       { bind2:
  432.                         X1=son(X1)=GLOTOP;
  433.                         X2=son(X2);
  434.                         bindspace(A1);
  435.                         for(;;)
  436.                           { if(name(X2)==SKELT) 
  437.                               { register TERM X;
  438.                                 X=B2+offset(X2); 
  439.                                 while(name(X)==VART) X=val(X);
  440.                                 name(X1)=VART;val(X1)=X;
  441.                                 if(--A1==0) break;
  442.                                 next_br(X1); next_br(X2);continue;
  443.                               }
  444.                             name(X1)=A2=name(X2);
  445.                             if(A2=arity(A2))
  446.                               { if(--A1 !=0)
  447.                                   { son(X1)=BIND((int)A2,son(X2),B2);
  448.                                     next_br(X1);next_br(X2); 
  449.                                     continue;
  450.                                   }
  451.                                 else
  452.                                   { A1=A2; goto bind2;}
  453.                               }
  454.                             val(X1)=val(X2);
  455.                             if(--A1==0) break;
  456.                             next_br(X1); next_br(X2);continue;
  457.                           }
  458.                       }
  459.                     else son(X1)=son(X2);
  460.                   }
  461.                 else  {  name(X1)=A2; val(X1)=val(X2);  }
  462.               } 
  463.             else goto failure;
  464.           else if(A1=arity(A2))
  465.             {func4:  
  466.               if(--N==0)
  467.                { N=A1; Y1=X1=son(X1);Y2=X2=son(X2);
  468.                  if(++TAILRECUR!=0) goto deref_top;
  469.                  ABORT(DEPTHE);
  470.                }        
  471.               if(!UNIFY((int)A1,son(X1),son(X2),B1,B2,DEPTH-1))
  472.                       goto failure;
  473.               X1=next_br(Y1); X2=next_br(Y2); continue;
  474.             }
  475.           else 
  476.             if(val(X1)!=val(X2)) goto failure;
  477.        }
  478. nextbrother:     
  479.     if(--N==0) goto success;
  480.     X1=next_br(Y1); X2=next_br(Y2);continue;
  481.   }
  482.   
  483. failure:        
  484.   GLOTOP=TOP; 
  485.   while(TEND<TRAILEND)
  486.    { X1=boundvar(dec_trail(TRAILEND)); name(X1)=UNBOUNDT;}
  487.   return false;
  488.  
  489. success: 
  490.   return true;
  491. }
  492.  
  493.  
  494.